home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
listlib.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
3KB
|
86 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; listlib.lsp
;;;;
;;;; list manipulating routines
(in-package 'lisp)
(export '(union nunion intersection nintersection
set-difference nset-difference set-exclusive-or nset-exclusive-or
subsetp))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defun union (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) list2)
((apply #'member1 (car list1) list2 rest)
(apply #'union (cdr list1) list2 rest))
(t
(cons (car list1)
(apply #'union (cdr list1) list2 rest)))))
(defun nunion (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) list2)
((apply #'member1 (car list1) list2 rest)
(apply #'nunion (cdr list1) list2 rest))
(t
(rplacd list1
(apply #'nunion (cdr list1) list2 rest)))))
(defun intersection (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) nil)
((apply #'member1 (car list1) list2 rest)
(cons (car list1)
(apply #'intersection (cdr list1) list2 rest)))
(t (apply #'intersection (cdr list1) list2 rest))))
(defun nintersection (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) nil)
((apply #'member1 (car list1) list2 rest)
(rplacd list1
(apply #'nintersection (cdr list1) list2 rest)))
(t (apply #'nintersection (cdr list1) list2 rest))))
(defun set-difference (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) nil)
((not (apply #'member1 (car list1) list2 rest))
(cons (car list1)
(apply #'set-difference (cdr list1) list2 rest)))
(t (apply #'set-difference (cdr list1) list2 rest))))
(defun nset-difference (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(cond ((null list1) nil)
((not (apply #'member1 (car list1) list2 rest))
(rplacd list1
(apply #'nset-difference (cdr list1) list2 rest)))
(t (apply #'nset-difference (cdr list1) list2 rest))))
(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(append (apply #'set-difference list1 list2 rest)
(apply #'set-difference list2 list1 rest)))
(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(nconc (apply #'set-difference list1 list2 rest)
(apply #'nset-difference list2 list1 rest)))
(defun subsetp (list1 list2 &rest rest &key test test-not key)
(declare (ignore test test-not key))
(do ((l list1 (cdr l)))
((null l) t)
(if (not (apply #'member1 (car l) list2 rest)) (return nil))))